// System Unit
// Thread Local Storage Support

(*************)
(* Interface *)
(*************)
{$IFDEF Include_Modules_Header}

 Var
  TLSIndex: Integer = -1;       { Thread local storage index }
  TLSLast: Byte;                { Set by linker so its offset is last in TLS segment }

 Type
  TLSEvent = ( tlsEventAlloc, tlsEventDealloc );
  TLSEventCallback = Procedure (Const EventType: TLSEvent);

 // WARNING: Thread-unsafe! Must be called serially
 // (Note that these function are normally called during unit initialization/finalization,
 //  which are called serially, so nothing special is needed)
 Function RegisterTLSEventMonitor(Func: TLSEventCallback): Cardinal;
 Procedure UnregisterTLSEventMonitor(FuncIdx: Cardinal);

 Function _GetTLS: Pointer;

{$ENDIF Include_Modules_Header}
(******************)
(* Implementation *)
(******************)
{$IFDEF Include_Modules_Implement}

 ResourceString
  _RTL_ResStr_TLSFreeBlockError = 'Error occured while releasing TLS buffer @ $$$$$$$$';

 Const
  MaxTLSEventMonitors = 32;

 Type
  // TFLDLItem compatible!
  PTLSEventRec = ^TLSEventRec;
  TLSEventRec = Record
   Proc: TLSEventCallback;
   Reserved: Pointer;
   Next, Prev: PTLSEventRec;
  END;

  // TFLDLHeader compatible!
  TLSEventListHeader = Record
   MaxSize, MinFree: Cardinal;
   Head, Tail: PTLSEventRec;
  END;

  // TFLDL compatible!
  TLSEvents = Record
   Header: TLSEventListHeader;
   List: Array[0..MaxTLSEventMonitors-1] of TLSEventRec;
  END;

 Var
  _INT_TLSEventMonitors: TLSEvents;

 Function RegisterTLSEventMonitor(Func: TLSEventCallback): Cardinal;
  BEGIN
   IF NOT Assigned(Func)
   then System.Error(reInvalidPtr);

   Result:= System.FLDL_Alloc(_INT_TLSEventMonitors);
   With _INT_TLSEventMonitors.List[Result] do
    Proc:= @Func;
  END;

 Procedure UnregisterTLSEventMonitor(FuncIdx: Cardinal);
  BEGIN
   System.FLDL_Free(_INT_TLSEventMonitors, FuncIdx);
  END;

 Procedure _INT_TLSEventNotify(Const EventType: TLSEvent);
  Var CallHead: PTLSEventRec;
  BEGIN
   Case EventType of
    tlsEventAlloc:
     BEGIN
      // Signal Alloc event in forward order
      CallHead:= _INT_TLSEventMonitors.Header.Head;
      While Assigned(CallHead) do
       BEGIN
        CallHead.Proc(EventType);
        CallHead:= CallHead.Next;
       END;
     END;

    tlsEventDealloc:
     BEGIN
      // Signal Dealloc event in reverse order
      CallHead:= _INT_TLSEventMonitors.Header.Tail;
      While Assigned(CallHead) do
       BEGIN
        CallHead.Proc(EventType);
        CallHead:= CallHead.Prev;
       END;
     END;

    else System.Error(reInvalidOp);
   END;
  END;

 Type
  PTLSBlockLink = ^TLSBlockLink;
  TLSBlockLink = Record
   Prev, Next: Pointer;
  END;

 Var
  _INT_TLSBlockRoot: Pointer = NIL;

 // TLS blocks are double-linked so that they don't leak when library is unloaded
 // [TLS Data] | (Alignment) | [TLSBlockLink]
 // \---------------------------\         /
 // /============================\=======/
 // [TLS Data] | (Alignment) | [TLSBlockLink]
 // \---------------------------\         /
 // /============================\=======/
 // [TLS Data] | (Alignment) | [TLSBlockLink]

 Function _INT_GetTLSSize: Cardinal; Inline;
  BEGIN
   Result:= NativeUInt(@TLSLast);
  END;

 Function _INT_AlignTLSSize(Const Size: Cardinal): Cardinal; Inline;
  BEGIN
   Result:= (Size + Sizeof(TLSBlockLink)-1) DIV Sizeof(TLSBlockLink) * Sizeof(TLSBlockLink) + Sizeof(TLSBlockLink);
  END;

 Function _INT_GetTLSBlockLink(Const Buffer: Pointer): PTLSBlockLink; Inline;
  BEGIN
   NativeUInt(Result):= NativeUInt(Buffer) + _INT_AlignTLSSize(_INT_GetTLSSize) - Sizeof(TLSBlockLink);
  END;

 Function _INT_AllocTLSBuffer(Const Size: Cardinal): Pointer; Inline;
  Const LMEM_ZEROINIT = $40;
  BEGIN
   Result:= _WIN_LocalAlloc(LMEM_ZEROINIT, _INT_AlignTLSSize(Size));
  END;

 Function _INT_FreeTLSBuffer(Const Buffer: Pointer): Pointer; Inline;
  BEGIN
   Result:= _WIN_LocalFree(Buffer);
  END;

 Procedure _INT_PrependTLSBlock(Const Buffer: Pointer);
  BEGIN
   IF Assigned(_INT_TLSBlockRoot)
   then _INT_GetTLSBlockLink(_INT_TLSBlockRoot).Prev:= Buffer;
   _INT_GetTLSBlockLink(Buffer).Next:= _INT_TLSBlockRoot;
   _INT_TLSBlockRoot:= Buffer;
  END;

 Procedure _INT_RemoveTLSBlock(Const Buffer: Pointer);
  Var TLSBlockNext, TLSBlockPrev: Pointer;
  BEGIN
   TLSBlockNext:= _INT_GetTLSBlockLink(Buffer).Next;
   TLSBlockPrev:= _INT_GetTLSBlockLink(Buffer).Prev;
   IF Assigned(TLSBlockNext)
   then _INT_GetTLSBlockLink(TLSBlockNext).Prev:= TLSBlockPrev;
   IF Assigned(TLSBlockPrev)
   then _INT_GetTLSBlockLink(TLSBlockPrev).Next:= TLSBlockNext
   else _INT_TLSBlockRoot:= TLSBlockNext;
  END;

 Function _INT_InitThreadTLSFunc: Pointer;
  BEGIN
   Result:= NIL;
   IF TLSIndex <> -1 then
    BEGIN
     Result:= _INT_AllocTLSBuffer(_INT_GetTLSSize);
     IF Result <> NIL then
      IF _WIN_TLSSetValue(TLSIndex, Result) then
       BEGIN
        _INT_PrependTLSBlock(Result);
        _INT_TLSEventNotify(tlsEventAlloc);
        Exit;
       END
      else _INT_FreeTLSBuffer(Result);
    END;

   System.Error(reInitFailure);
  END;

 Procedure _INT_InitThreadTLS;
  ASM
{$IFNDEF RTL_LazyTLS}
   JMP _INT_InitThreadTLSFunc;
{$ENDIF RTL_LazyTLS}
  END;

 Procedure _INT_InitProcessTLS;
  BEGIN
   // Initialize event record array
   System.FLDL_Init(_INT_TLSEventMonitors, MaxTLSEventMonitors);

   IF _INT_GetTLSSize = 0 then Exit;

   IF TLSIndex = -1
   then TLSIndex:= _WIN_TLSAlloc;

   _INT_InitThreadTLS;
  END;

 Procedure _INT_ExitThreadTLS;
  Var Buffer: Pointer;
  BEGIN
   IF TLSIndex <> -1 then
    BEGIN
     Buffer:= _WIN_TLSGetValue(TLSIndex);
     IF Buffer <> NIL then
      BEGIN
       _INT_TLSEventNotify(tlsEventDealloc);
       _INT_RemoveTLSBlock(Buffer);
       IF _INT_FreeTLSBuffer(Buffer) = NIL
        then _WIN_TLSSetValue(TLSIndex, NIL)
        else
         BEGIN
          _INT_PrependTLSBlock(Buffer);
          System.Error(reInvalidPtr);
         END;
      END;
    END;
  END;

 Procedure _INT_ExitProcessTLS;
  Procedure _LOC_LogTLSFreeBlockError(Buffer: Pointer);
   Var
    ErrMsg: Array [0..RTL_ResStr_MsgLen] of Char;
    MsgLen: Cardinal;
   BEGIN
    MsgLen:= LoadResStringFx(@_RTL_ResStr_TLSFreeBlockError, ErrMsg, RTL_ResStr_MsgLen+1);
    System.RTL_CardinalToHex8(NativeUInt(Buffer), @ErrMsg[MsgLen-8]);
    System.Log(llWarn, ErrMsg);
   END;

  Var TLSBlock, FreeBlock: Pointer;
  BEGIN
   IF TLSIndex <> -1 then
    BEGIN
     _WIN_TLSFree(TLSIndex);

     // Proceed to free all TLS blocks
     TLSBlock:= _INT_TLSBlockRoot;
     While Assigned(TLSBlock) do
      BEGIN
       FreeBlock:= TLSBlock;
       TLSBlock:= _INT_GetTLSBlockLink(TLSBlock).Next;

       // Free TLS block, or log error
       IF _INT_FreeTLSBuffer(FreeBlock) <> NIL
       then _LOC_LogTLSFreeBlockError(FreeBlock);
      END;
    END;
  END;

 Function _GetTLS: Pointer;
  ASM
   PUSH TLSIndex
   CALL _WIN_TLSGetValue
   TEST EAX, EAX
   JE   _INT_InitThreadTLSFunc
  END;

{$ENDIF Include_Modules_Implement}

